home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / modula2 / granule / storbase.imp < prev   
Encoding:
Text File  |  1994-09-22  |  18.1 KB  |  609 lines
  1. -------------------------------------------------------------------------*)
  2.  
  3. IMPLEMENTATION MODULE StorBase;
  4.  
  5. (* Idee         : Johannes Leckebusch, Peter Sollich    *)
  6. (* Realisation  : Peter Sollich                         *)
  7. (* Dynamic-Heap : Peter Hellinger                       *)
  8. (* Stand        : 04.12.88                              *)
  9.  
  10. (*$V- *) (* Overflow-Checks *)
  11. (*$R- *) (* Range-Checks    *)
  12. (*$S- *) (* Stack-Check     *)
  13. (*$N- *) (* NIL-Checks      *)
  14. (*$T- *) (* Range- und Overflow-Checks für TDI-Compiler vor 3.01 *)
  15. (*$Q+ *) (* Modul-Intern Branch-Befehle statt Jumps verwenden *)
  16.  
  17. FROM SYSTEM IMPORT  ADDRESS, NULL;
  18. FROM RTError IMPORT ErrorHalt;
  19. IMPORT  GEMDOS;
  20.  
  21. (*#######################################################################*)
  22.  
  23. CONST   lisp            = FALSE; 
  24.  
  25.         (* Falls Lispmap gewünscht, bitte dieses Flag auf TRUE sezten *)
  26.  
  27. (*#######################################################################*)
  28.  
  29. (*CONST   cgrain          = 16;*)
  30. CONST   cSetGrain       = LONGCARD(8);  (* Granule-Setgröße   *)
  31.         cMinHeapSize    =          64;  (* Minimum-Heap       *)
  32.         cMaxHeapSize    =    16777215;  (* 16 Megabyte maximaler Heap   *)
  33.         cMaxGranules    =     1048575;  (* Maximale Anzahl der Granules *)
  34.         cBytesInSet     =      131071;  (* Maximum Bytes im Set *)
  35.         GEMReserve      =     010000H;  (* 64kb Restspeicher für GEM *)
  36.  
  37.  
  38. TYPE    BlockPtr        = POINTER TO Block; (* Zeiger auf ein Element des Heaps *)
  39.         Block           = RECORD
  40.                            bigger : BlockPtr; (* Zeiger auf größere Blöcke (rechts) *)
  41.                            equal  : BlockPtr; (* Zeiger auf kleinere Blöcke (links) *)
  42.                            back   : BlockPtr; (* Zeiger auf den vorhergehenden Block *)
  43.                            size   : LONGCARD; (* Größe des Blocks *)
  44.                           END;
  45.  
  46.  
  47. TYPE    ByteSet         = SET OF [0..7]; (* Basistyp für das BitmapSet *)
  48.         mapSet          = ARRAY [0..cBytesInSet] OF ByteSet;
  49.  
  50.  
  51. VAR     root            : BlockPtr;     (* Die Wurzel unseres Baumes    *)
  52.         initialBlock    : BlockPtr;     (* Erster Block des Baumes      *)
  53.         largeSentinel   : BlockPtr;     (* Lezter Block im Heap         *)
  54.         freeMap         : POINTER TO mapSet;
  55.         lispMap         : POINTER TO mapSet;
  56.         GranulesUsed    : LONGCARD;     (* Wird vorerst nicht mehr benutzt *)
  57.         heapUsed        : LONGCARD;     (* Anzahl der benutzten Bytes   *)
  58.         heapStart       : ADDRESS;
  59.         heapSize        : LONGCARD;     (* Größe des Heap               *)
  60.         Dynamic         : BOOLEAN;      (* Flag für Dynamic-Option      *)
  61.         defaultSize     : LONGCARD;     (* Standardgröße für Heaperweiterung *)
  62.         FreeMapSize     : LONGCARD;     (* Größe der Bitmap             *)
  63.         MaxHeapSize     : LONGCARD;     (* Maximale Größe des Heaps     *)
  64.         MemoryBottom    : ADDRESS;      (* Unteres Ende des Speichers   *)
  65.         PhysicalTop     : ADDRESS;      (* Oberes Ende des Speichers    *)
  66.  
  67.  
  68.  
  69. PROCEDURE AppendHeap (Amount: LONGCARD; mark: BOOLEAN): BOOLEAN;
  70. (* fügt neuen Block in den Heap ein, FALSE wenn nicht möglich *)
  71.  
  72. VAR Block, b1:  BlockPtr;
  73.     adr:        ADDRESS;
  74.     lc:         LONGCARD;
  75. VAR l,g:        LONGCARD;
  76.  
  77. BEGIN
  78.  
  79.  (* erst mal Testen ob soviel Speicher da ist *)
  80.  GEMDOS.Alloc(0FFFFFFFFH,adr); lc:= LONGCARD(adr);
  81.  IF (lc>GEMReserve) THEN
  82.   DEC(lc,GEMReserve) (* Gemdos-Minimum reservieren *)
  83.  ELSE
  84.   Dynamic:= FALSE; (* Speicher kleiner als GEMReserve -> nix geht mehr *)
  85.   RETURN FALSE; 
  86.  END; 
  87.  
  88.  IF lc<Amount THEN
  89.   Amount:=lc;
  90.   Dynamic:=FALSE;
  91.   (* Kein Speicher mehr zur Verfügung -> AppendHeap darf nicht mehr
  92.    * aufgerufen werden, da sonst Restspeicher für GEM verbraten wird!
  93.    *)
  94.  END;
  95.  
  96.  (* Nur Vielfache von cgrain als Blockgröße zulassen *)
  97.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  98.  
  99.  (* Testen, ob Amount im gültigen Bereich *)
  100.  IF (Amount<cMinHeapSize) OR (Amount>MaxHeapSize) THEN
  101.   Dynamic:= FALSE; RETURN FALSE;
  102.  END;
  103.  
  104.  (* Speicher abrufen *) 
  105.  GEMDOS.Alloc(Amount,Block);
  106.  IF Block=NULL THEN
  107.   Dynamic:=FALSE;
  108.   RETURN FALSE
  109.  END;
  110.  
  111.  INC(heapSize,Amount); (* neue Heapgröße berechnen *)
  112.  largeSentinel^.size:= heapSize+1;
  113.  
  114.  (* Unseren neuen Block als von ALLOCATE behandelt tarnen  *)
  115.  (* 04.12.88: Wie hat das bloß jemals funktionieren können ??? *)
  116.  Block^.size:= Amount-(cgrain * 2);
  117.  b1:= (ADDRESS(Block)+ADDRESS(Block^.size))-ADDRESS(cgrain);
  118.  b1^.size:= Block^.size;
  119.  INC(heapUsed,Amount);  (* Zur Tarnung *)
  120.  
  121.   (* Nun wird der Block noch in der Bitmap als Belegt gekennzeichnet.
  122.    * Es genügt, das erste Bit zu setzen, da deallocate auch nur das
  123.    * erste Block-Bit in der freeMap testet.  Zeit ist Geld!
  124.    *)
  125.   l:= LONGCARD( ADDRESS(Block) - MemoryBottom) DIV cgrain;
  126.   g:= Amount DIV cgrain;
  127.   EXCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  128.   IF lisp AND mark THEN
  129.    EXCL(lispMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  130.   END;
  131.  
  132.  (* Und nun der Clou: wir schicken den Block durch DEALLOCATE !! *)
  133.  dealloc(Block,Amount,mark);
  134.  
  135.  RETURN TRUE;
  136. END AppendHeap;
  137.  
  138. PROCEDURE allocate (VAR Addr: ADDRESS; Amount: LONGCARD; mark: BOOLEAN);
  139. VAR Block,b : BlockPtr;
  140.     b1,b2,b3: BlockPtr;
  141.     l,g     : LONGCARD;
  142.     m       : LONGCARD; (* für Testzwecke *)
  143.     i       : INTEGER;  (* für createheap *)
  144. BEGIN
  145.  
  146.  Addr:= NIL; (* Na denn... *)
  147.  
  148.  (* Wenn nicht installiert, muß der Heap initialisiert werden *)
  149.  IF root = NIL THEN
  150.   IF (Amount>=defaultSize) THEN
  151.    i:= createheap(Amount+defaultSize);
  152.   ELSE
  153.    i:= createheap(defaultSize);
  154.   END;
  155.   IF i<0 THEN RETURN; END;
  156.   (* hier kann nur 0 oder -1 zurückkommen, da root=NIL *)
  157.  END;
  158.  
  159.  IF (Amount>heapSize) THEN (* Grmpfft! Siehe Bugnote 25.11.88 *)
  160.   IF Dynamic THEN
  161.    IF NOT AppendHeap(Amount,mark) THEN RETURN END;
  162.   ELSE
  163.    RETURN;
  164.   END;
  165.  END;
  166.  
  167.  Block:= root; (* Laufzeiger auf Beginn des Heap-Baumes *)
  168.  
  169.  (* Nur Vielfache von cgrain als Blockgröße zulassen *)
  170.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  171.  
  172.  (* Suche nach einem Block größer oder gleich dem Angeforderten *)
  173.  REPEAT Block:= Block^.bigger UNTIL Block^.size>Amount;
  174.  
  175.  IF Block^.size>heapSize THEN (* Heapoverflow !! *)
  176.   IF Dynamic THEN
  177.    IF NOT AppendHeap(defaultSize,mark) THEN RETURN END; (* nichts geht mehr *)
  178.    allocate(Addr,Amount,mark);
  179.   ELSE
  180.    RETURN;
  181.   END;
  182.   RETURN;
  183.  END;
  184.  
  185.  b1:= Block^.back; (* b1 = vorhergehender Block *)
  186.  
  187.  IF Block^.size=Amount THEN
  188.   (* Block hat gleiche Größe wie angefordert, das ist einfach *)
  189.  
  190.   (*-- Block aus der Liste lösen und Liste restaurieren --*)
  191.   b2:= Block^.equal;
  192.   b3:= Block^.bigger;
  193.   IF b2=NIL THEN
  194.    b1^.bigger:= b3;
  195.    b3^.back:= b1;
  196.   ELSE
  197.    b1^.bigger:= b2;
  198.    b2^.bigger:= b3;
  199.    b2^.back:= b1;
  200.    b3^.back:= b2;
  201.   END;
  202.  
  203.  ELSE (* Block ist größer als angefordert -> nu wirds kompliziert *)
  204.  
  205.  (* In Verbindung mit der dynamischen Erweiterungsmöglichkeit des Heaps
  206.   * ergibt sich hier ein gar nicht so leicht aufzudeckender Fehler:
  207.   *
  208.   * Der allozierte Speicher wird am OBEREN Ende des gefundenen Blocks
  209.   * abgezweigt. Hierdurch entsteht der Effekt, daß die Daten in UMGE-
  210.   * kehrter Reihenfolge im Heap stehen - also die zuerst abgelegten Daten
  211.   * auf höheren Adressen als die zuletzt abgelegten. Der Heap wächst 
  212.   * gewissermaßen "nach unten".
  213.   *
  214.   * Wird nun mittels AppendHeap ein neuer Block in den Heap integriert,
  215.   * wird er in aller Regel eine höhere Adresse als der bereits bestehende
  216.   * Heap haben, also im Speicher weiter "hinten" liegen.
  217.   *
  218.   * Da der oberste Block des bereits bestehenden Heaps auch in aller Regel
  219.   * belegt sein wird (er wird ja schließlich als erster alloziert) kann 
  220.   * deallocate den neuen Block nicht mit dem Rest des bestehenden Heaps
  221.   * verschmelzen - der Rest steht ja am BEGINN des Blocks, nicht am Ende
  222.   * wie es notwendig wäre.
  223.   *
  224.   * So können Blöcke entstehen, die nicht mehr durchs Programm allozierbar
  225.   * sind, da sie einfach zu klein sind. Je nachdem, wie die durchschnittliche
  226.   * Blockgröße aussieht, kann so ein Rest zwischen 1 und 100 Kilobyte
  227.   * entstehen (bei einem freien Speicher von ca 3.5 Mb).
  228.   *
  229.   * Ich habe versucht diesen Fehler auszumerzen, indem ich die Allozierungs-
  230.   * reihenfolge geändert habe. Der Rest-Heap sollte nun am Ende des Blocks
  231.   * stehen und sich mit dem neuen Block verschmelzen lassen.
  232.   *
  233.   * Hp 25.12.88
  234.   *)
  235.  
  236.   Addr:= Block; (* die halbe Miete hätten wir... *)
  237.  
  238.   (*-- Block aus Liste nehmen und Liste restaurieren --*)
  239.   b2:= Block^.equal;
  240.   b3:= Block^.bigger;
  241.   IF b2 = NIL THEN
  242.    b1^.bigger:= b3;
  243.    b3^.back:= b1;
  244.   ELSE
  245.    b1^.bigger:= b2;
  246.    b2^.bigger:= b3;
  247.    b2^.back:= b1;
  248.    b3^.back:= b2;
  249.   END;
  250.  
  251.   (* Block-Pointer "nach oben" verschieben *)
  252.   b:= ADDRESS(Block) + ADDRESS(Amount);
  253.   b^.bigger:= Block^.bigger;
  254.   b^.equal := Block^.equal;
  255.   b^.back  := Block^.back;
  256.   b^.size  := Block^.size - Amount;
  257.   Block:= b;
  258.  
  259.   (* Nun suchen wir ein trautes Plätzchen für den Rest unseres Blocks *)
  260.  
  261.   b2:= root;
  262.   REPEAT b2:= b2^.bigger UNTIL b2^.size>=Block^.size;
  263.   (* b2 zeigt auf einen Block größer oder gleich unseres Blockrestes *)
  264.  
  265.   (* Block an neuer Stelle einfügen *)
  266.   b1:= b2^.back;
  267.   b1^.bigger:= Block; 
  268.   Block^.back:= b1;
  269.   b2^.back:= Block;
  270.   IF b2^.size>Block^.size THEN
  271.    (* Block zwischen b1 und b2 einfügen *)
  272.    Block^.bigger:= b2;
  273.    Block^.equal := NIL;
  274.   ELSE
  275.    (* Block nach b2 einfügen *)
  276.    b3:= b2^.bigger;
  277.    Block^.bigger:= b3;
  278.    Block^.equal:= b2;
  279.    b3^.back:= Block;
  280.   END;
  281.  
  282.   (* oberes Ende des Blocks berechnen *)
  283.   b2:= (ADDRESS(Block) + ADDRESS(Block^.size)) - ADDRESS(cgrain);
  284.   b2^.size:= Block^.size; 
  285.  END (* IF Block^.Amount = Amount *);
  286.  
  287.  (* Nun wird der Block noch in der Bitmap als Belegt gekennzeichnet *)
  288.  l:= LONGCARD(Addr-MemoryBottom) DIV cgrain;
  289.  g:= Amount DIV cgrain;
  290.  INC(heapUsed,Amount);
  291.  REPEAT
  292.   EXCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  293.   IF lisp AND mark THEN
  294.    EXCL(lispMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  295.   END;
  296.   INC(l); DEC(g);
  297.  UNTIL g=0;
  298.  
  299.  (* Uff... *)
  300. END allocate;
  301.  
  302.  
  303. PROCEDURE deallocrest (VAR Addr: ADDRESS; Amount: LONGCARD;
  304.                       VAR new: LONGCARD; mark: BOOLEAN);
  305. VAR newAddr   : ADDRESS;
  306.     newAmount : LONGCARD;
  307. BEGIN
  308.  IF Addr # NIL THEN
  309.   INC (Amount, (cgrain-1) - (Amount+ (cgrain-1)) MOD cgrain);
  310.   INC (new, (cgrain-1) - (new + (cgrain-1)) MOD cgrain);
  311.   IF (new > Amount) THEN
  312.    dealloc (Addr, Amount, mark);
  313.   ELSE
  314.    newAddr:= Addr + ADDRESS (new);
  315.    newAmount:= Amount - new;
  316.    dealloc (newAddr, newAmount, mark);
  317.   END;
  318.  END;
  319. END deallocrest;
  320.  
  321.  
  322. PROCEDURE dealloc (VAR Addr: ADDRESS; Amount: LONGCARD; mark: BOOLEAN);
  323. VAR  s,b,b1,b2,b3 : BlockPtr;
  324.      l,r,g        : LONGCARD;
  325. BEGIN
  326.  
  327.  IF Addr=NIL THEN RETURN END; (* gibts sonst Bömbchen *)
  328.  
  329.  (* Nur Vielfaches von cgrain als Größe zulassen *)
  330.  INC(Amount,(cgrain-1) - (Amount+(cgrain-1)) MOD cgrain);
  331.  
  332.  (* Schutz vor Doppelten Pointern *)
  333.  l:= LONGCARD((Addr-MemoryBottom) DIV cgrain);
  334.  IF (SHORT(l MOD cSetGrain) IN ByteSet(freeMap^[l DIV cSetGrain]))
  335.   THEN
  336.    Addr:= NIL; 
  337.    ErrorHalt ('STORBASE| double pointer deallocation');
  338.    RETURN;
  339.   END;
  340.  
  341.  (* Block in der Bitmap als frei kennzeichnen *)
  342.  (* l:= LONGCARD ((Addr-MemoryBottom) DIV cgrain);  Ist hier überflüssig *)
  343.  g:= Amount DIV cgrain;
  344.  DEC(heapUsed,Amount);
  345.  r:= l;
  346.  REPEAT
  347.   INCL(freeMap^[r DIV cSetGrain],SHORT(r MOD cSetGrain));
  348.  
  349.   IF lisp AND mark THEN
  350.    INCL(lispMap^[r DIV cSetGrain],SHORT(r MOD cSetGrain));
  351.   END;
  352.  
  353.   INC(r); DEC(g)
  354.  UNTIL g=0;
  355.  
  356.  s:= root; (* Start des Heap *)
  357.  b:= Addr; (* Adresse des Blocks *)
  358.  
  359.  (* physikalisch Rechten Nachbar in der Bitmap auf Frei testen *)
  360.  IF SHORT(r MOD cSetGrain) IN ByteSet(freeMap^[r DIV cSetGrain]) THEN
  361.  
  362.   b:= ADDRESS(b) + ADDRESS(Amount); (* Adresse des Blocks berechnen *)
  363.   INC (Amount, b^.size); (* Blockgröße zu der Unseren addieren *)
  364.  
  365.   (* Die Zeiger der beiden Blöcke verküpfen *)
  366.   b1:= b^.back; b2:= b^.equal;
  367.   IF b1^.size=b^.size THEN
  368.    b1^.equal:= b2;
  369.    IF b2#NIL THEN b2^.back:= b1 END;
  370.   ELSE
  371.    b3:= b^.bigger; s:= b3;
  372.    IF b2 = NIL THEN
  373.     b1^.bigger:= b3; b3^.back:= b1;
  374.    ELSE
  375.     b1^.bigger:= b2; b2^.bigger:= b3; b2^.back:= b1; b3^.back:= b2;
  376.    END;
  377.   END;
  378.   b:= Addr;
  379.  
  380.  END; (* IF SHORT *) 
  381.  
  382.  (* physikalisch Linken Nachbar in der Bitmap auf Frei testen *)
  383.  IF SHORT((l-1) MOD cSetGrain) IN ByteSet(freeMap^[(l-1) DIV cSetGrain]) THEN
  384.   b1:= ADDRESS(b) - cgrain; 
  385.  
  386.   (* In allocate haben wir auf die letzten 4 Bytes die Größe des Blocks
  387.    * eingetragen. Die holen wir uns nun mittels b1... *)
  388.   b:= Addr - ADDRESS(b1^.size); (* Startadresse des linken Blocks *)
  389.  
  390.   INC(Amount,b^.size); 
  391.   b1:=b^.back; b2:= b^.equal;
  392.  
  393.   IF b1^.size=b^.size THEN
  394.    b1^.equal:= b2;
  395.    IF b2#NIL THEN b2^.back:= b1 END;
  396.   ELSE
  397.    b3:= b^.bigger;
  398.    IF s^.size<b3^.size THEN s:= b3 END;
  399.    IF b2=NIL THEN
  400.     b1^.bigger:= b3; b3^.back:= b1;
  401.    ELSE
  402.     b1^.bigger:= b2; b2^.bigger:= b3; b2^.back:= b1; b3^.back:= b2;
  403.    END (* IF b2=NIL *);
  404.   END (* IF b1^.Amount *);
  405.  
  406.  END (* IF l - 1 *);
  407.  
  408.  b^.size:= Amount; b1:= ADDRESS(b)+ADDRESS(Amount)-cgrain;
  409.  b1^.size:= Amount; b2:= s;
  410.  WHILE b2^.size<Amount DO b2:=b2^.bigger END;
  411.  b1:= b2^.back; b1^.bigger:= b; b^.back:= b1; b2^.back:= b;
  412.  IF b2^.size>Amount THEN (* insert b between b1 and b2 *)
  413.   b^.bigger:= b2; b^.equal:= NIL;
  414.  ELSE (* insert b above b2 *)
  415.   b3:= b2^.bigger; b^.bigger:= b3; b^.equal:= b2; b3^.back:= b;
  416.  END (* IF b2^.size *);
  417.  
  418.  Addr:= NIL; (* Schwitz... *)
  419.  
  420. END dealloc;
  421.  
  422.  
  423.  
  424. PROCEDURE createheap (Amount: LONGCARD): INTEGER;
  425. VAR smallSentinel: BlockPtr;
  426.     i,l,g        : LONGCARD;
  427.     a            : ADDRESS;  (*21.12.88 Hp*)
  428. BEGIN
  429.  
  430.  (* Fehler, wenn Heap schon existiert *)
  431.  IF root#NIL THEN RETURN -2 END;
  432.  
  433.  (* Mal sehen was so im Speicher rumliegt *)
  434.  GEMDOS.Alloc(0FFFFFFFFH,a);
  435.  l:=LONGCARD(a); DEC(l,GEMReserve);
  436.  
  437.  (* Bereich testen und Heapsize korrigieren *) 
  438.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  439.  IF l<Amount THEN Amount:=l; END;
  440.  IF (Amount<cMinHeapSize) OR (Amount>l) THEN RETURN -1; END;
  441.  
  442.  (* Speicher anfordern *)
  443.  GEMDOS.Alloc(Amount,heapStart);
  444.  
  445.  heapSize:= Amount;
  446.  
  447.  smallSentinel:= heapStart;             (* unteres Ende des Heaps *)
  448.  largeSentinel:= heapStart+cgrain;      (* Zeiger auf obere Ende des Heap *)
  449.  initialBlock := heapStart+cgrain*2;    (* Erster Block des Heap *)
  450.  
  451.  (* "kleinen Wächter" initalisieren *)
  452.  WITH smallSentinel^ DO
  453.   bigger:= initialBlock;
  454.   equal := NIL;
  455.   back  := NIL;
  456.   size  :=   0; 
  457.  END;
  458.  
  459.  (* "großen Wächter" initialisieren *)
  460.  WITH largeSentinel^ DO
  461.   bigger:= NIL;
  462.   equal := NIL;
  463.   back  := initialBlock;
  464.   size  := heapSize+1;
  465.   (* Aktuelle Heapgröße +1. So wird in allocate das Ende des Heaps erkannt. *)
  466.  END;
  467.  
  468.  (* Ersten Block intialisieren *)
  469.  WITH initialBlock^ DO
  470.   bigger:= largeSentinel;
  471.   equal := NIL;
  472.   back  := smallSentinel;
  473.   size  := Amount-(cgrain * 2);
  474.   DEC(size,size MOD cgrain);
  475.  END;
  476.  
  477.  heapUsed:= cgrain * 2;
  478.  
  479.  root:= smallSentinel;
  480.  
  481.  (* Heap in der Bitmap als frei kennzeichnen *)
  482.  l:= LONGCARD( (heapStart + ADDRESS(cgrain * 2)) - MemoryBottom) DIV cgrain;
  483.  g:= Amount DIV cgrain;
  484.  REPEAT
  485.   INCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  486.  
  487.   IF lisp THEN
  488.    INCL(lispMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  489.   END;
  490.  
  491.   INC(l); DEC(g);
  492.  UNTIL g=0;
  493.  
  494.  (* Kennzeichnet unteres Ende des Heap *)
  495.  EXCL(freeMap^[0],1);
  496.  
  497.  IF lisp THEN EXCL(lispMap^[0],1); END;
  498.  
  499.  RETURN 0;
  500. END createheap;
  501.  
  502.  
  503. PROCEDURE free(): LONGCARD;
  504. BEGIN
  505.  RETURN heapSize - heapUsed;
  506. END free;
  507.  
  508.  
  509. PROCEDURE heapbase (): ADDRESS;
  510. BEGIN
  511.  RETURN initialBlock;
  512. END heapbase;
  513.  
  514.  
  515. PROCEDURE granulemarked (addr: ADDRESS): BOOLEAN;
  516. VAR l: LONGCARD;
  517. BEGIN
  518.  IF lisp THEN
  519.   l:= LONGCARD((addr-MemoryBottom) DIV cgrain);
  520.   RETURN 
  521.    ~(SHORT((l-1) MOD cSetGrain) IN ByteSet(lispMap^[(l-1) DIV cSetGrain]));
  522.  ELSE
  523.   RETURN FALSE;
  524.  END;
  525. END granulemarked;
  526.  
  527.  
  528. PROCEDURE usedgran (mark: BOOLEAN): LONGCARD;
  529. BEGIN
  530.  (* Da sollte wohl noch was kommen... ?!? *)
  531.  RETURN heapUsed DIV cgrain;
  532. END usedgran;
  533.  
  534.  
  535. PROCEDURE dynamic (dyn: BOOLEAN);
  536. BEGIN
  537.  Dynamic:= dyn;
  538. END dynamic;
  539.  
  540.  
  541. PROCEDURE setDefaultSize (size: LONGCARD);
  542. BEGIN
  543.  defaultSize:= size;
  544. END setDefaultSize;
  545.  
  546.  
  547. PROCEDURE memAvail(): LONGCARD;
  548. VAR a: ADDRESS;
  549.     l: LONGCARD;
  550. BEGIN
  551.  GEMDOS.Alloc(0FFFFFFFFH,a);
  552.  RETURN (heapSize + LONGCARD(a)) - (heapUsed + GEMReserve);
  553. END memAvail;
  554.  
  555.  
  556. VAR     c       : LONGCARD;
  557.         a       : ADDRESS;
  558.         x       : POINTER TO LONGCARD;
  559.         y       : POINTER TO CHAR;
  560.         phystop[042EH]: ADDRESS;        (* Systemvariable *)
  561.         membot[0432H] : ADDRESS;        (* Systemvariable *)
  562.  
  563. BEGIN
  564.  
  565.  Dynamic      := TRUE;          (* Dynamic-Option gewählt       *)
  566.  defaultSize  := 010000H;       (* 64Kb Default Heapsize        *)
  567.  GranulesUsed := 0;             (* Noch kein Granule gebraucht  *)
  568.  heapUsed     := 0;             (* Noch kein Byte belegt        *)
  569.  root         := NIL;           (* Heap ist leer                *)
  570.  
  571.  (* maximale Speichergröße feststellen *)
  572.  a:=0; GEMDOS.Super(a);
  573.  PhysicalTop  := phystop;
  574.  MemoryBottom := membot;
  575.  GEMDOS.Super(a);
  576.  
  577.  (* Maximale Größe des freien Speichers *)
  578.  MaxHeapSize:= LONGCARD( PhysicalTop - MemoryBottom);
  579.  
  580.  (* Größe der Bitmap berechnen *)
  581.  FreeMapSize:= MaxHeapSize DIV (cgrain * cSetGrain);
  582.  INC(FreeMapSize);
  583.  
  584.  (* Speicher anfordern *)
  585.  GEMDOS.Alloc(FreeMapSize,freeMap);
  586.  IF (freeMap=NULL) THEN ErrorHalt('STORBASE| Freemap not generated'); END;
  587.  (* Hier könnte man noch ne Msg. bringen *)
  588.  
  589.  (* Bitmap löschen. Geht so schneller *)
  590.  x:= ADDRESS(freeMap);
  591.  FOR c:=0 TO (FreeMapSize DIV 4) DO x^:=0; (*INC(x,4);*)
  592.      INC (x); INC (x); INC (x); INC (x);
  593.  END;
  594.  y:= ADDRESS(x);
  595.  FOR c:=0 TO (FreeMapSize MOD 4) DO y^:=0C; INC(y); END;
  596.  
  597.  (* Lispmap initialisieren *)
  598.  IF lisp THEN
  599.   GEMDOS.Alloc(FreeMapSize,lispMap);
  600.   IF (lispMap=NULL) THEN ErrorHalt('STORBASE| Lispmap not generated'); END;
  601.   x:= ADDRESS(lispMap);
  602.   FOR c:=0 TO (FreeMapSize DIV 4) DO x^:=0; INC(x,4); END;
  603.   y:= ADDRESS(x);
  604.   FOR c:=0 TO (FreeMapSize MOD 4) DO y^:=0C; INC(y); END;
  605.  END;
  606.  
  607. END StorBase.
  608.  
  609. ə